#!/usr/bin/perl

my $infile = shift or die "Can't open input file.\n";

BEGIN {
    my %local_jump_id;
    my $local_id = 0;

    sub getLocalId
    { 
	my ($n) = @_;
	
	if (!exists($local_jump_id{$n}))
	{
	    $local_jump_id{$n} = ++$local_id;
	}
	
	return $local_jump_id{$n};
    }

    sub resetLocalIds
    {
	%local_jump_id = ();
	$local_id = 0;
    }
}

#load byte codes from C format header file
open(BCFILE, "bytecodes.h") or die "Can't open byte code header file.\n";
my %codes;

while ($line = <BCFILE>)
{
    if ($line =~ /^#define[ \t]*(\w*)[ \t]*(\w*)/)
    {
	$codes{$1} = hex($2);
    }
}
close BCFILE;


my %functions;

open (INFILE, $infile) or die "Can't open input file: $infile\n";
open (OUTFILE, ">$infile" . 'bc') or die "Can't open output file\n";
binmode(OUTFILE); #Ensure carriage returns aren't added

#read entire assembly file
local $\;
my @code = <INFILE>;
close INFILE;


#assemble functions to bytecode
for ($i = 0; $i < scalar(@code); $i++)
{
    my $bytecode = "";
    my $line = $code[$i];
    
    if ($line =~ /^[ \t]*([A-Za-z][.A-Za-z0-9]*):/)
    {
	my $name = $1;
	($i, $bytecode) = asmFunc($i + 1, @code);
	print "Function $name is ". length($bytecode) . " bytes long\n";
	$functions{$name} = pack("C", $codes{'DEFUN'}) . "$name\000$bytecode" . pack("C", $codes{'END'});
    }
}

#write functions out to file
my $bytecode;
my $function_table;

#set up function table, and concatenate byte code
while(my ($fname, $bc) = each %functions)
{
    $function_table .= pack("N", length($bytecode));
    $bytecode .= $bc;
}


my $header;
$header .= pack("N", 0xbcbcbcbc); # magic
$header .= pack("N", 0x00000000); # extra info
$header .= pack("N", 0);  # extra info
$header .= pack("N", 28); # offset of function table
$header .= pack("N", 28 + length($function_table)); # bytecode offset
$header .= pack("N", length($function_table));
$header .= pack("N", length($bytecode));

print OUTFILE "$header$function_table$bytecode";
close OUTFILE;

sub parseArg
{
    my ($arg) = @_;

    # floating point
    if ($arg =~ /[ \t]*(\d*\.\d+(e-?\d+)?)/)
    {
	return "$1\000";
    }

    # hex integer
    elsif ($arg =~ /[ \t]*0x(-?[0-9a-fA-F]+)/)
    {
	return pack("N", hex($1));
    }

    # regular integer
    elsif ($arg =~ /[ \t]*(-?[0-9]+)/)
    {
	return pack("N", $1);
    }

    # simple string
    elsif ($arg =~ /[ \t]*"([^"]*)"/)
    {
	return "$1\000";
    }


}


sub asmFunc
{
    my ($i, @code) = @_;

    my $bytecode;
    my %local_ids;
    my %unresolved;

    for ($i; $i < scalar(@code); $i++)
    {
	my $line = $code[$i];
	
	# new function line - we're done, exit this subroutine
	if ($line =~ /^[ \t]*([A-Za-z][.A-Za-z0-9]*):/)
	{
	    $i--;
	    last;
	}
	
	# local label line
	elsif ($line =~ /^[ \t]*(.\w+):/)
	{
	    my $lid = getLocalId($1);
	    $local_ids{$lid} = $1;
	    delete $unresolved{$lid};
	    $bytecode .= pack('CN', $codes{'LABEL'}, $lid);
	}

	elsif ($line =~ /^[ \t]*(\w+)(.*)/)
	{
	    my $opcode = $1;
	    my $rest = $2;

	    if (!exists $codes{$opcode})
	    {
		print "Error: unrecognized opcode on line " . ($i + 1) . "\n";
		exit(1);
	    }

	    if ($opcode eq 'CLEANARGS')
	    {
		if ($rest =~ /[ \t]*(\d+)/)
		{
		    $bytecode .= pack('CC', $codes{$opcode}, int($1));
		}
		else
		{
		    print "CLEANARGS without number of arguments.\n";
		    exit(1);
		}
	    }
	    
	    elsif ($opcode eq 'CALL')
	    {
		if ($rest =~ /[ \t]*([a-zA-Z]+[.a-zA-Z0-9]*)[ \t]+(\d+)/)
		{
		    $bytecode .= pack('CC', $codes{$opcode}, int($2)) . "$1\000";
		}
		else
		{
		    print "Illegal function call\n";
		    exit(1);
		}
	    }

	    elsif ($opcode eq 'TAILCALL')
	    {
		if ($rest =~ /[ \t]*(\d+)[ \t]+([a-zA-Z]+[.a-zA-Z0-9]*)[ \t]+(\d+)/)
		{
		    $bytecode .= pack('CCC', $codes{$opcode}, int($1), int($3)) . "$2\000";
		}
		else
		{
		    print "Illegal tail call\n";
		    exit(1);
		}
	    }

	    elsif ($opcode eq 'JMP' or $opcode eq 'JCOND')
	    {
		if ($rest !~ /[ \t]*(\.\w+)/)
		{
		    print "Error in jump call on line $i\n";
		    exit(1);
		}

		my $lid = getLocalId($1);
		
		# if we haven't seen this local label yet, mark as unresolved
		if (! exists $local_ids{$lid})
		{
		    $unresolved{$lid} = $1;
		}
		$bytecode .= pack('CN', $codes{$opcode}, $lid);
	    }

	    elsif ($opcode eq 'SPAWN')
	    {
		if ($rest !~ /[ \t]*([a-zA-Z]+[.a-zA-Z0-9]*)/)
		{
		    print "Error in spawn call on line $i: $rest\n";
		    exit(1);
		}
		$bytecode .= pack('C', $codes{$opcode}) . "$1\000";
	    }

	    elsif ($opcode eq 'STACKALLOC')
	    {
		if ($rest !~ /[ \t]*(\d{1,3})/)
		{
		    print "Error in STACKALLOC call on line $i: $rest\n";
		    exit(1);
		}
		$bytecode .= pack('CC', $codes{$opcode}, int($1));
	    }

	    elsif ($opcode eq 'PUSHBIGINT')
	    {
		if ($rest !~ /[ \t]*([-+]?\d+)/)
		{
		    print "Error in PUSHBIGINT call on line $i: $rest\n";
		    exit(1);
		}
		$bytecode .= pack('C', $codes{$opcode}) . "$1\000";
	    }

	    #no args
	    elsif ($codes{$opcode} < $codes{'PUSHINT'})
	    {
		$bytecode .= pack('C', $codes{$opcode});
	    }

	    #single arg
	    elsif ($codes{$opcode} < $codes{'CALL'})
	    {
		$bytecode .= pack('C', $codes{$opcode}) . parseArg($rest);
	    }
	}
    }

    while (my ($lid, $name) = each %unresolved)
    {
	print "Error: unresolved local label $name\n";
	exit(1);
    }

    resetLocalIds();
    return ($i, $bytecode);
}


